home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Visual Database / Visual Foxpro 6.0 (Ent. Edition) / Vf6ent Extractor.EXE / SCCTEXT.PRG < prev    next >
Encoding:
Text File  |  1998-05-26  |  58.0 KB  |  2,127 lines
  1. *+--------------------------------------------------------------------------
  2. *
  3. *    File:        SCCTEXT.PRG
  4. *
  5. *    Copyright:    (c) 1995, Microsoft Corporation.
  6. *                All Rights Reserved.
  7. *
  8. *    Contents:    Routines for creating text representations of .SCX, .VCX,
  9. *                .MNX, .FRX, and .LBX files for the purpose of supporting
  10. *                merge capabilities in source control systems.
  11. *
  12. *   Author:        Sherri Kennamer
  13. *
  14. *    Parameters:    cTableName    C    Fully-qualified name of the SCX/VCX/MNX/FRX/LBX
  15. *                cType        C    Code indicating the file type
  16. *                                (See PRJTYPE_ constants, defined below)
  17. *                cTextName    C    Fully-qualified name of the text file
  18. *                lGenText    L    .T. Create a text file from the table
  19. *                                .F. Create a table from the text file
  20. *
  21. *    Returns:    0        File or table was successfully generated
  22. *                -1        An error occurred
  23. *
  24. *    History:    17-Aug-95    sherrike    written
  25. *                20-Nov-95    sherrike    use smart defaults for single filename
  26. *                02-Dec-95    sherrike    return values for merge support
  27. *
  28. *---------------------------------------------------------------------------
  29.  
  30. #include "foxpro.h"
  31.  
  32. #define C_DEBUG .F.
  33.  
  34. * If merge support is 1 and C_WRITECHECKSUMS is .T., write a checksum (sys(2007)) instead of
  35. * converting binary to ascii. This drastically improves performance because OLE controls can
  36. * be large and time-consuming to convert.
  37. #define C_WRITECHECKSUMS .T.
  38.  
  39. #define SCCTEXTVER_LOC "SCCTEXT Version 4.0.0.2"
  40.  
  41. #define ALERTTITLE_LOC "Microsoft Visual FoxPro"
  42. #define ERRORTITLE_LOC "Program Error"
  43. #define ERRORMESSAGE_LOC ;
  44.     "Error #" + alltrim(str(m.nError)) + " in " + m.cMethod + ;
  45.     " (" + alltrim(str(m.nLine)) + "): " + m.cMessage
  46.  
  47. #define ERR_FOXERROR_11_LOC "Function argument value, type, or count is invalid."
  48. #define ERR_NOTABLE_LOC "A table name is required."
  49. #define ERR_FILENOTFOUND_LOC "File not found: "
  50. #define ERR_UNSUPPORTEDFILETYPE_LOC "File type not supported: "
  51. #define ERR_BIN2TEXTNOTSUPPORTED_LOC "Text file generation not supported for type '&cType' files."
  52. #define ERR_TEXT2BINNOTSUPPORTED_LOC "Binary file generation not supported for type '&cType' files."
  53. #define ERR_UNSUPPORTEDFIELDTYPE_LOC "Field type not supported: "
  54. #define ERR_INVALIDTEXTNAME_LOC "Invalid TEXTNAME parameter."
  55. #define ERR_INVALIDREVERSE_LOC "Invalid REVERSE parameter."
  56. #define ERR_NOTEXTFILE_LOC "Text file name is required to create a table."
  57. #define ERR_FCREATE_LOC "FCREATE() error: "
  58. #define ERR_FOPEN_LOC "FOPEN() error: "
  59. #define ERR_FIELDLISTTOOLONG_LOC "Field list is too long."
  60. #define ERR_BADVERSION_LOC "Bad SCCTEXT version."
  61. #define ERR_LINENOACTION_LOC "No action was taken on line: "
  62. #define ERR_ALERTCONTINUE_LOC "Continue?"
  63. #define ERR_OVERWRITEREADONLY_LOC "File &cParameter1 is read-only. Overwrite it?"
  64. #define ERR_MAXBINLEN_LOC "MAXBINLEN value must be a multiple of 8. Program aborted."
  65.  
  66. #define CRLF chr(13) + chr(10)
  67. #define MAXBINLEN    96        && this value must be a multiple of 8!!!
  68.  
  69. #define FILE_ATTRIBUTE_NORMAL    128
  70.  
  71. * Text file support for each file type
  72. *    0 indicates no text file support
  73. *    1 indicates one-way support (to text)
  74. *    2 indicates two-way support (for merging)
  75. #define SCC_FORM_SUPPORT    1
  76. #define SCC_LABEL_SUPPORT    1
  77. #define SCC_MENU_SUPPORT    1
  78. #define SCC_REPORT_SUPPORT    1
  79. #define SCC_VCX_SUPPORT        1
  80. #define SCC_DBC_SUPPORT        0
  81.  
  82. * These are the extensions used for the text file
  83. #define SCC_ASCII_FORM_EXT        "SCA"
  84. #define SCC_ASCII_LABEL_EXT        "LBA"
  85. #define SCC_ASCII_MENU_EXT        "MNA"
  86. #define SCC_ASCII_REPORT_EXT    "FRA"
  87. #define SCC_ASCII_VCX_EXT        "VCA"
  88. #define SCC_ASCII_DBC_EXT        "DBA"
  89.  
  90. * These are the extensions used for the binary file
  91. #define SCC_FORM_EXT        "SCX"
  92. #define SCC_LABEL_EXT        "LBX"
  93. #define SCC_MENU_EXT        "MNX"
  94. #define SCC_REPORT_EXT        "FRX"
  95. #define SCC_VCX_EXT            "VCX"
  96. #define SCC_DBC_EXT            "DBC"
  97.  
  98. * These are the extensions used for the binary file
  99. #define SCC_FORM_MEMO        "SCT"
  100. #define SCC_LABEL_MEMO        "LBT"
  101. #define SCC_MENU_MEMO        "MNT"
  102. #define SCC_REPORT_MEMO        "FRT"
  103. #define SCC_VCX_MEMO        "VCT"
  104. #define SCC_DBC_MEMO        "DBT"
  105.  
  106. * These are the project type identifiers for the files
  107. #define PRJTYPE_FORM        "K"
  108. #define PRJTYPE_LABEL        "B"
  109. #define PRJTYPE_MENU        "M"
  110. #define PRJTYPE_REPORT        "R"
  111. #define PRJTYPE_VCX            "V"
  112. #define PRJTYPE_DBC            "d"
  113.  
  114. * These are the extensions used for table backups
  115. #define SCC_FORM_TABLE_BAK        "SC1"
  116. #define SCC_FORM_MEMO_BAK        "SC2"
  117. #define SCC_LABEL_TABLE_BAK        "LB1"
  118. #define SCC_LABEL_MEMO_BAK        "LB2"
  119. #define SCC_MENU_TABLE_BAK        "MN1"
  120. #define SCC_MENU_MEMO_BAK        "MN2"
  121. #define SCC_REPORT_TABLE_BAK    "FR1"
  122. #define SCC_REPORT_MEMO_BAK        "FR2"
  123. #define SCC_VCX_TABLE_BAK        "VC1"
  124. #define SCC_VCX_MEMO_BAK        "VC2"
  125. #define SCC_DBC_TABLE_BAK        "DB1"
  126. #define SCC_DBC_MEMO_BAK        "DB2"
  127. #define SCC_DBC_INDEX_BAK        "DB3"
  128.  
  129. * These are the extensions used for text file backups
  130. #define SCC_FORM_TEXT_BAK        "SCB"
  131. #define SCC_LABEL_TEXT_BAK        "LBB"
  132. #define SCC_MENU_TEXT_BAK        "MNB"
  133. #define SCC_REPORT_TEXT_BAK        "FRB"
  134. #define SCC_VCX_TEXT_BAK        "VCB"
  135. #define SCC_DBC_TEXT_BAK        "DBB"
  136.  
  137. * These are used for building markers used to parse the text back into a table
  138. #define MARKMEMOSTARTWORD    "[START "
  139. #define MARKMEMOSTARTWORD2    "]"
  140. #define MARKMEMOENDWORD        "[END "
  141. #define MARKMEMOENDWORD2    "]"
  142. #define MARKBINSTARTWORD    "[BINSTART "
  143. #define MARKBINSTARTWORD2    "]"
  144. #define MARKBINENDWORD        "[BINEND "
  145. #define MARKBINENDWORD2        "]"
  146. #define MARKFIELDSTART        "["
  147. #define MARKFIELDEND        "] "
  148. #define MARKEOF                "[EOF]"
  149. #define MARKRECORDSTART        "["
  150. #define MARKRECORDEND        " RECORD]"
  151. #define MARKCHECKSUM        "CHECKSUM="
  152.  
  153. #define SKIPEMPTYFIELD        .T.
  154.  
  155. * These are used to override default behavior for specific fields
  156. #define VCX_EXCLUDE_LIST        " OBJCODE TIMESTAMP "
  157. #define VCX_MEMOASCHAR_LIST        " CLASS CLASSLOC BASECLASS OBJNAME PARENT "
  158. #define VCX_MEMOASBIN_LIST        " OLE OLE2 "
  159. #define VCX_CHARASBIN_LIST        ""
  160. #define VCX_MEMOVARIES_LIST        " RESERVED4 RESERVED5 "
  161.  
  162. #define FRX_EXCLUDE_LIST        " TIMESTAMP "
  163. #define FRX_MEMOASCHAR_LIST        " NAME STYLE PICTURE ORDER FONTFACE "
  164. #define FRX_MEMOASBIN_LIST        " TAG TAG2 "
  165. #define FRX_CHARASBIN_LIST        ""
  166. #define FRX_MEMOVARIES_LIST        ""
  167.  
  168. #define MNX_EXCLUDE_LIST        " TIMESTAMP "
  169. #define MNX_MEMOASCHAR_LIST        " NAME PROMPT COMMAND MESSAGE KEYNAME KEYLABEL "
  170. #define MNX_MEMOASBIN_LIST        ""
  171. #define MNX_CHARASBIN_LIST        " MARK "
  172. #define MNX_MEMOVARIES_LIST        ""
  173.  
  174. #define DBC_EXCLUDE_LIST        ""
  175. #define DBC_MEMOASCHAR_LIST        ""
  176. #define DBC_MEMOASBIN_LIST        ""
  177. #define DBC_CHARASBIN_LIST        ""
  178. #define DBC_MEMOVARIES_LIST        " PROPERTY CODE USER "
  179.  
  180. * Used by the thermometer
  181. #define C_THERMLABEL_LOC        "Generating &cThermLabel"
  182. #define C_THERMCOMPLETE_LOC        "Generate &cThermLabel complete!"
  183. #DEFINE WIN32FONT                "MS Sans Serif"
  184. #DEFINE WIN95FONT                "Arial"
  185. #define C_BINARYCONVERSION_LOC    "Converting binary data: &cBinaryProgress.%"
  186.  
  187. parameters cTableName, cType, cTextName, lGenText
  188. LOCAL iParmCount
  189. iParmCount = parameters()
  190.  
  191. LOCAL  obj, iResult
  192. m.iResult = -1
  193. if m.iParmCount = 1 .and. type('m.cTableName') = 'C'
  194.     * Check to see if we've been passed only a PRJTYPE value. If so, return a
  195.     * value to indicate text support for the file type.
  196.     *    0 indicates no text file support
  197.     *    1 indicates one-way support (to text)
  198.     *    2 indicates two-way support (for merging)
  199.     *  -1 indicates m.cTableName is not a recognized file type
  200.     m.iResult = TextSupport(m.cTableName)
  201. endif
  202. if m.iResult = -1 && .and. file(m.cTableName)
  203.     m.obj = createobj("SccTextEngine", m.cTableName, m.cType, m.cTextName, m.lGenText, m.iParmCount)
  204.     if type("m.obj") = "O" .and. .not. isnull(m.obj)
  205.         obj.Process()
  206.         if type("m.obj") = "O" .and. .not. isnull(m.obj)
  207.             m.iResult = obj.iResult
  208.         endif
  209.     endif
  210.     release m.obj
  211. endif
  212. return (m.iResult)
  213.  
  214. procedure TextSupport
  215.     parameters cFileType
  216.     do case
  217.     * Check to see if we've been passed only a PRJTYPE value. If so, return a
  218.     * value to indicate text support for the file type.
  219.     *    0 indicates no text file support
  220.     *    1 indicates one-way support (to text)
  221.     *    2 indicates two-way support (for merging)
  222.     case m.cFileType == PRJTYPE_FORM
  223.         return SCC_FORM_SUPPORT
  224.     case m.cFileType == PRJTYPE_LABEL
  225.         return SCC_LABEL_SUPPORT
  226.     case m.cFileType == PRJTYPE_MENU
  227.         return SCC_MENU_SUPPORT
  228.     case m.cFileType == PRJTYPE_REPORT
  229.         return SCC_REPORT_SUPPORT
  230.     case m.cFileType == PRJTYPE_VCX
  231.         return SCC_VCX_SUPPORT
  232.     case m.cFileType == PRJTYPE_DBC
  233.         return SCC_DBC_SUPPORT
  234.     otherwise
  235.         return -1
  236.     endcase
  237. endproc
  238.  
  239. define class SccTextEngine as custom
  240.     HadError = .f.
  241.     iError = 0
  242.     cMessage = ""
  243.     SetErrorOff = .f.
  244.  
  245.     iResult = -1 && Fail
  246.     cTableName = ""
  247.     cMemoName = ""
  248.     cIndexName = ""
  249.     cTextName = ""
  250.     
  251.     lMadeBackup = .F.
  252.     cTableBakName = ""
  253.     cMemoBakName = ""
  254.     cIndexBakName = ""
  255.     cTextBakName = ""
  256.     
  257.     cVCXCursor = ""        && If we're generating text for a .VCX, we create a temporary
  258.                         && file with the classes sorted.
  259.     
  260.     cType = ""
  261.     lGenText = .t.
  262.     iHandle = -1
  263.     dimension aEnvironment[1]
  264.     
  265.     oThermRef = ""
  266.     
  267.     procedure Init(cTableName, cType, cTextName, lGenText, iParmCount)
  268.         local iAction
  269.         
  270.         if m.iParmCount = 1 .and. type('m.cTableName') = 'C'
  271.             * Interpret the single parameter as a filename and be smart about defaults
  272.             if this.IsBinary(m.cTableName)
  273.                 m.cType = this.GetPrjType(m.cTableName)
  274.                 m.cTextName = this.ForceExt(m.cTableName, this.GetAsciiExt(m.cType))
  275.                 m.lGenText = .t.
  276.             else
  277.                 if this.IsAscii(m.cTableName)
  278.                     m.cType = this.GetPrjType(m.cTableName)
  279.                     m.cTextName = m.cTableName
  280.                     m.cTableName = this.ForceExt(m.cTextName, this.GetBinaryExt(m.cType))
  281.                     m.lGenText = .f.
  282.                 endif
  283.             endif
  284.         endif
  285.         
  286.         this.cTableName = m.cTableName
  287.         this.cType = m.cType
  288.         this.cTextName = m.cTextName
  289.         this.lGenText = m.lGenText
  290.         
  291.         * Verify that we've got valid parameters
  292.         if type('this.cTableName') <> 'C' .or. type('this.cType') <> 'C' ;
  293.             .or. type('this.cTextName') <> 'C' .or. type('this.lGenText') <> 'L'
  294.             this.Alert(ERR_FOXERROR_11_LOC)
  295.             return .f.
  296.         endif
  297.         
  298.         * REC00XYS Verify parameters before calling this.ForceExt
  299.         this.cMemoName = this.ForceExt(this.cTableName, this.GetBinaryMemo(this.cType))
  300.  
  301.         * Verify that we support the requested action
  302.         m.iAction = iif(m.lGenText, 1, 2)
  303.         do case
  304.         case m.cType == PRJTYPE_FORM .and. SCC_FORM_SUPPORT < m.iAction
  305.             m.iAction = m.iAction * -1
  306.         case m.cType == PRJTYPE_LABEL .and. SCC_LABEL_SUPPORT < m.iAction
  307.             m.iAction = m.iAction * -1
  308.         case m.cType == PRJTYPE_MENU .and. SCC_MENU_SUPPORT < m.iAction
  309.             m.iAction = m.iAction * -1
  310.         case m.cType == PRJTYPE_REPORT .and. SCC_REPORT_SUPPORT < m.iAction
  311.             m.iAction = m.iAction * -1
  312.         case m.cType == PRJTYPE_VCX .and. SCC_VCX_SUPPORT < m.iAction
  313.             m.iAction = m.iAction * -1
  314.         case m.cType == PRJTYPE_DBC .and. SCC_DBC_SUPPORT < m.iAction
  315.             m.iAction = m.iAction * -1
  316.         endcase
  317.  
  318.         if m.iAction = -1
  319.             this.Alert(ERR_BIN2TEXTNOTSUPPORTED_LOC)
  320.             return .f.
  321.         endif
  322.         if m.iAction = -2
  323.             this.Alert(ERR_TEXT2BINNOTSUPPORTED_LOC)
  324.             return .f.
  325.         endif
  326.             
  327.         if .not. this.Setup()
  328.             return .f.
  329.         endif
  330.         
  331.         if (MAXBINLEN % 8 <> 0)
  332.             this.Alert(ERR_MAXBINLEN_LOC)
  333.             return .f.
  334.         endif
  335.     endproc
  336.  
  337.     procedure Erase
  338.         parameters cFilename
  339.         if !empty(m.cFilename) .and. file(m.cFilename)
  340.             =SetFileAttributes(m.cFilename, FILE_ATTRIBUTE_NORMAL)
  341.             erase (m.cFilename)
  342.         endif
  343.     endproc
  344.     
  345.     procedure MakeBackup
  346.         * Fill in the names of the backup files
  347.         do case
  348.         case this.cType = PRJTYPE_FORM
  349.             this.cTextBakName = this.ForceExt(this.cTextName, SCC_FORM_TEXT_BAK)
  350.             this.cTableBakName = this.ForceExt(this.cTableName, SCC_FORM_TABLE_BAK)
  351.             this.cMemoBakName = this.ForceExt(this.cMemoName, SCC_FORM_MEMO_BAK)
  352.         case this.cType = PRJTYPE_REPORT
  353.             this.cTextBakName = this.ForceExt(this.cTextName, SCC_REPORT_TEXT_BAK)
  354.             this.cTableBakName = this.ForceExt(this.cTableName, SCC_REPORT_TABLE_BAK)
  355.             this.cMemoBakName = this.ForceExt(this.cMemoName, SCC_REPORT_MEMO_BAK)
  356.         case this.cType = PRJTYPE_VCX
  357.             this.cTextBakName = this.ForceExt(this.cTextName, SCC_VCX_TEXT_BAK)
  358.             this.cTableBakName = this.ForceExt(this.cTableName, SCC_VCX_TABLE_BAK)
  359.             this.cMemoBakName = this.ForceExt(this.cMemoName, SCC_VCX_MEMO_BAK)
  360.         case this.cType = PRJTYPE_MENU
  361.             this.cTextBakName = this.ForceExt(this.cTextName, SCC_MENU_TEXT_BAK)
  362.             this.cTableBakName = this.ForceExt(this.cTableName, SCC_MENU_TABLE_BAK)
  363.             this.cMemoBakName = this.ForceExt(this.cMemoName, SCC_MENU_MEMO_BAK)
  364.         case this.cType = PRJTYPE_LABEL
  365.             this.cTextBakName = this.ForceExt(this.cTextName, SCC_LABEL_TEXT_BAK)
  366.             this.cTableBakName = this.ForceExt(this.cTableName, SCC_LABEL_TABLE_BAK)
  367.             this.cMemoBakName = this.ForceExt(this.cMemoName, SCC_LABEL_MEMO_BAK)
  368.         case this.cType = PRJTYPE_DBC
  369.             this.cTextBakName = this.ForceExt(this.cTextName, SCC_DBC_TEXT_BAK)
  370.             this.cTableBakName = this.ForceExt(this.cTableName, SCC_DBC_TABLE_BAK)
  371.             this.cMemoBakName = this.ForceExt(this.cMemoName, SCC_DBC_MEMO_BAK)
  372.             this.cIndexBakName = this.ForceExt(this.cIndexName, SCC_DBC_INDEX_BAK)
  373.         endcase
  374.         
  375.         * Delete any existing backup
  376.         this.DeleteBackup()
  377.         
  378.         * Create new backup files
  379.         if this.lGenText
  380.             if file(this.cTextName)
  381.                 copy file (this.cTextName) to (this.cTextBakName)
  382.             endif
  383.         else
  384.             if file(this.cTableName) .and. file(this.cMemoName)
  385.                 copy file (this.cTableName) to (this.cTableBakName)
  386.                 copy file (this.cMemoName) to (this.cMemoBakName)
  387.                 if !empty(this.cIndexName) .and. file(this.cIndexName)
  388.                     copy file (this.cIndexName) to (this.cIndexBakName)
  389.                 endif
  390.             endif
  391.         endif
  392.  
  393.         this.lMadeBackup = .T.
  394.     endproc
  395.     
  396.     procedure RestoreBackup
  397.         if this.lGenText
  398.             this.Erase(this.cTextName)
  399.         else
  400.             this.Erase(this.cTableName)
  401.             this.Erase(this.cMemoName)
  402.             if .not. empty(this.cIndexName)
  403.                 this.Erase(this.cIndexName)
  404.             endif
  405.         endif
  406.         
  407.         if this.lGenText
  408.             if file(this.cTextBakName)
  409.                 copy file (this.cTextBakName) to (this.cTextName)
  410.             endif
  411.         else
  412.             if file(this.cTableBakName) .and. file(this.cMemoBakName)
  413.                 copy file (this.cTableBakName) to (this.cTableName)
  414.                 copy file (this.cMemoBakName) to (this.cMemoName)
  415.                 if !empty(this.cIndexBakName) .and. file(this.cIndexBakName)
  416.                     copy file (this.cIndexBakName) to (this.cIndexName)
  417.                 endif
  418.             endif
  419.         endif
  420.     endproc
  421.     
  422.     procedure DeleteBackup
  423.         if this.lGenText
  424.             this.Erase(this.cTextBakName)
  425.         else
  426.             this.Erase(this.cTableBakName)
  427.             this.Erase(this.cMemoBakName)
  428.             if !empty(this.cIndexBakName)
  429.                 this.Erase(this.cIndexBakName)
  430.             endif
  431.         endif
  432.     endproc
  433.     
  434.     procedure GetAsciiExt
  435.         parameters cType
  436.         do case
  437.         case m.cType = PRJTYPE_FORM
  438.             return SCC_ASCII_FORM_EXT
  439.         case m.cType = PRJTYPE_REPORT
  440.             return SCC_ASCII_REPORT_EXT
  441.         case m.cType = PRJTYPE_VCX
  442.             return SCC_ASCII_VCX_EXT
  443.         case m.cType = PRJTYPE_MENU
  444.             return SCC_ASCII_MENU_EXT
  445.         case m.cType = PRJTYPE_LABEL
  446.             return SCC_ASCII_LABEL_EXT
  447.         case m.cType = PRJTYPE_DBC
  448.             return SCC_ASCII_DBC_EXT
  449.         endcase
  450.     endproc
  451.     
  452.     procedure GetBinaryExt
  453.         parameters cType
  454.         do case
  455.         case m.cType = PRJTYPE_FORM
  456.             return SCC_FORM_EXT
  457.         case m.cType = PRJTYPE_REPORT
  458.             return SCC_REPORT_EXT
  459.         case m.cType = PRJTYPE_VCX
  460.             return SCC_VCX_EXT
  461.         case m.cType = PRJTYPE_MENU
  462.             return SCC_MENU_EXT
  463.         case m.cType = PRJTYPE_LABEL
  464.             return SCC_LABEL_EXT
  465.         case m.cType = PRJTYPE_DBC
  466.             return SCC_DBC_EXT
  467.         endcase
  468.     endproc
  469.     
  470.     procedure GetBinaryMemo
  471.         parameters cType
  472.         do case
  473.         case m.cType = PRJTYPE_FORM
  474.             return SCC_FORM_MEMO
  475.         case m.cType = PRJTYPE_REPORT
  476.             return SCC_REPORT_MEMO
  477.         case m.cType = PRJTYPE_VCX
  478.             return SCC_VCX_MEMO
  479.         case m.cType = PRJTYPE_MENU
  480.             return SCC_MENU_MEMO
  481.         case m.cType = PRJTYPE_LABEL
  482.             return SCC_LABEL_MEMO
  483.         case m.cType = PRJTYPE_DBC
  484.             return SCC_DBC_MEMO
  485.         endcase
  486.     endproc
  487.     
  488.     procedure GetPrjType
  489.         parameters cFileName
  490.         local m.cExt
  491.         m.cExt = upper(this.JustExt(m.cFileName))
  492.         do case
  493.         case inlist(m.cExt, SCC_ASCII_FORM_EXT, SCC_FORM_EXT)
  494.             return PRJTYPE_FORM
  495.         case inlist(m.cExt, SCC_ASCII_REPORT_EXT, SCC_REPORT_EXT)
  496.             return PRJTYPE_REPORT
  497.         case inlist(m.cExt, SCC_ASCII_VCX_EXT, SCC_VCX_EXT)
  498.             return PRJTYPE_VCX
  499.         case inlist(m.cExt, SCC_ASCII_MENU_EXT, SCC_MENU_EXT)
  500.             return PRJTYPE_MENU
  501.         case inlist(m.cExt, SCC_ASCII_LABEL_EXT, SCC_LABEL_EXT)
  502.             return PRJTYPE_LABEL
  503.         case inlist(m.cExt, SCC_ASCII_DBC_EXT, SCC_DBC_EXT)
  504.             return PRJTYPE_DBC
  505.         otherwise
  506.             return ''
  507.         endcase
  508.     endproc
  509.     
  510.     procedure IsAscii
  511.         parameters cFileName
  512.         local m.cExt
  513.         m.cExt = upper(this.JustExt(m.cFileName))
  514.         return inlist(m.cExt, SCC_ASCII_FORM_EXT, SCC_ASCII_REPORT_EXT, SCC_ASCII_VCX_EXT, ;
  515.             SCC_ASCII_MENU_EXT, SCC_ASCII_LABEL_EXT, SCC_ASCII_DBC_EXT)
  516.     endproc
  517.     
  518.     procedure IsBinary
  519.         parameters cFileName
  520.         local m.cExt
  521.         m.cExt = upper(this.JustExt(m.cFileName))
  522.         return inlist(m.cExt, SCC_FORM_EXT, SCC_REPORT_EXT, SCC_VCX_EXT, ;
  523.             SCC_MENU_EXT, SCC_LABEL_EXT, SCC_DBC_EXT)
  524.     endproc
  525.     
  526.     procedure Setup
  527.         
  528.         dimension this.aEnvironment[5]
  529.         
  530.         this.aEnvironment[1] = set("deleted")
  531.         this.aEnvironment[2] = select()
  532.         this.aEnvironment[3] = set("safety")
  533.         this.aEnvironment[4] = set("talk")
  534.         this.aEnvironment[5] = set("asserts")
  535.         
  536.         SET TALK OFF
  537.  
  538.         declare INTEGER SetFileAttributes in win32api ;
  539.             STRING lpFileName, INTEGER dwFileAttributes
  540.         declare INTEGER sprintf in msvcrt40.dll ;
  541.             STRING @lpBuffer, string lpFormat, integer iChar1, integer iChar2, ;
  542.             integer iChar3, integer iChar4, integer iChar5, integer iChar6, ;
  543.             integer iChar7, integer iChar8
  544.  
  545.         set safety off
  546.         set deleted off
  547.         select 0
  548.         if C_DEBUG
  549.             set asserts on
  550.         endif
  551.         
  552.     endproc
  553.     
  554.     procedure Cleanup
  555.         local array aEnvironment[alen(this.aEnvironment)]
  556.         =acopy(this.aEnvironment, aEnvironment)
  557.         set deleted &aEnvironment[1]
  558.         set safety &aEnvironment[3]
  559.         use
  560.         select (aEnvironment[2])
  561.         if this.iHandle <> -1
  562.             =fclose(this.iHandle) 
  563.             this.iHandle = -1
  564.         endif
  565.         SET TALK &aEnvironment[4]        
  566.         if used(this.cVCXCursor)
  567.             use in (this.cVCXCursor)
  568.             this.cVCXCursor = ""
  569.         endif
  570.         set asserts &aEnvironment[5]
  571.     endproc
  572.     
  573.     procedure Destroy
  574.         if type("this.oThermRef") = "O"
  575.             this.oThermRef.Release()
  576.         endif
  577.     
  578.         this.Cleanup
  579.         
  580.         if this.lMadeBackup
  581.             if this.iResult <> 0
  582.                 this.RestoreBackup()
  583.             endif
  584.             this.DeleteBackup()
  585.         endif
  586.     endproc
  587.     
  588.     PROCEDURE Error
  589.         Parameters nError, cMethod, nLine, oObject, cMessage
  590.  
  591.         local cAction
  592.         
  593.         THIS.HadError = .T.
  594.         this.iError = m.nError
  595.         this.cMessage = iif(empty(m.cMessage), message(), m.cMessage)
  596.     
  597.         if this.SetErrorOff
  598.             RETURN
  599.         endif
  600.         
  601.         m.cMessage = iif(empty(m.cMessage), message(), m.cMessage)
  602.         if type("m.oObject") = "O" .and. .not. isnull(m.oObject) .and. at(".", m.cMethod) = 0
  603.             m.cMethod = m.oObject.Name + "." + m.cMethod
  604.         endif
  605.                 
  606.         if C_DEBUG
  607.             m.cAction = this.Alert(ERRORMESSAGE_LOC, MB_ICONEXCLAMATION + ;
  608.                 MB_ABORTRETRYIGNORE, ERRORTITLE_LOC)
  609.             do case
  610.             case m.cAction="RETRY"
  611.                 this.HadError = .f.
  612.                 clear typeahead
  613.                 set step on
  614.                 &cAction
  615.             case m.cAction="IGNORE"
  616.                 this.HadError = .f.
  617.                 return
  618.             endcase
  619.         else
  620.             if m.nError = 1098
  621.                 * User-defined error
  622.                 m.cAction = this.Alert(message(), MB_ICONEXCLAMATION + ;
  623.                     MB_OK, ERRORTITLE_LOC)
  624.             else
  625.                 m.cAction = this.Alert(ERRORMESSAGE_LOC, MB_ICONEXCLAMATION + ;
  626.                     MB_OK, ERRORTITLE_LOC)
  627.             endif
  628.         endif
  629.         this.Cancel
  630.  
  631.     ENDPROC
  632.     
  633.     procedure Cancel
  634.         parameters cMessage
  635.         if !empty(m.cMessage)
  636.             m.cAction = this.Alert(m.cMessage)
  637.         endif
  638.         return to Process -1
  639.     endproc
  640.     
  641.     PROCEDURE Alert
  642.         parameters cMessage, cOptions, cTitle, cParameter1, cParameter2
  643.  
  644.         private cOptions, cResponse
  645.  
  646.         m.cOptions = iif(empty(m.cOptions), 0, m.cOptions)
  647.  
  648.         if parameters() > 3 && a parameter was passed
  649.             m.cMessage = [&cMessage]
  650.         endif
  651.         
  652.         clear typeahead
  653.         if !empty(m.cTitle)
  654.             m.cResponse = MessageBox(m.cMessage, m.cOptions, m.cTitle)
  655.         else
  656.             m.cResponse = MessageBox(m.cMessage, m.cOptions, ALERTTITLE_LOC)
  657.         endif
  658.  
  659.         do case
  660.         * The strings below are used internally and should not 
  661.         * be localized
  662.         case m.cResponse = 1
  663.             m.cResponse = "OK"
  664.         case m.cResponse = 6
  665.             m.cResponse = "YES"
  666.         case m.cResponse = 7
  667.             m.cResponse = "NO"
  668.         case m.cResponse = 2
  669.             m.cResponse = "CANCEL"
  670.         case m.cResponse = 3
  671.             m.cResponse = "ABORT"
  672.         case m.cResponse = 4
  673.             m.cResponse = "RETRY"
  674.         case m.cResponse = 5
  675.             m.cResponse = "IGNORE"
  676.         endcase
  677.         return m.cResponse
  678.  
  679.     ENDPROC
  680.  
  681.     procedure Process
  682.         local cThermLabel
  683.         
  684.         if this.FilesAreWritable()
  685.             * Backup the file(s)
  686.  
  687.             this.MakeBackup()
  688.             
  689.             * Create and show the thermometer
  690.             m.cThermLabel = iif(this.lGenText, this.cTextName, this.cTableName)
  691.             this.oThermRef = createobject("thermometer", C_THERMLABEL_LOC)
  692.             this.oThermRef.Show()
  693.             
  694.             if this.lGenText
  695.                 this.iResult = this.WriteTextFile()
  696.             else
  697.                 this.iResult = this.WriteTableFile()
  698.             endif
  699.             
  700.             if this.iResult = 0
  701.                 this.oThermRef.Complete(C_THERMCOMPLETE_LOC)
  702.             endif
  703.         endif
  704.     endproc
  705.     
  706.     procedure FilesAreWritable
  707.         private aText
  708.         if this.lGenText
  709.             * Verify we can write the text file
  710.             if (adir(aText, this.cTextName) = 1 .and. 'R' $ aText[1, 5])
  711.                 if this.Alert(ERR_OVERWRITEREADONLY_LOC, MB_YESNO, '', this.cTextName) = "NO"
  712.                     return .f.
  713.                 endif
  714.             endif
  715.             =SetFileAttributes(this.cTextName, FILE_ATTRIBUTE_NORMAL)
  716.         else
  717.             * Verify we can write the table
  718.             if (adir(aText, this.cTableName) = 1 .and. 'R' $ aText[1, 5])
  719.                 if this.Alert(ERR_OVERWRITEREADONLY_LOC, MB_YESNO, '', this.cTableName) = "NO"
  720.                     return .f.
  721.                 endif
  722.             else
  723.                 if (adir(aText, this.cMemoName) = 1 .and. 'R' $ aText[1, 5])
  724.                     if this.Alert(ERR_OVERWRITEREADONLY_LOC, MB_YESNO, '', this.cMemoName) = "NO"
  725.                         return .f.
  726.                     endif
  727.                 endif
  728.             endif
  729.             =SetFileAttributes(this.cTableName, FILE_ATTRIBUTE_NORMAL)
  730.             =SetFileAttributes(this.cMemoName, FILE_ATTRIBUTE_NORMAL)
  731.         endif
  732.         return .t.
  733.     endproc
  734.     
  735.     procedure WriteTableFile
  736.         this.iHandle = fopen(this.cTextName)
  737.         if this.iHandle = -1
  738.             this.Alert(ERR_FOPEN_LOC + this.cTextName)
  739.             return -1
  740.         endif
  741.  
  742.         this.oThermRef.iBasis = fseek(this.iHandle, 0, 2)
  743.         fseek(this.iHandle, 0, 0)
  744.         
  745.         this.ValidVersion(fgets(this.iHandle, 65000))
  746.         this.CreateTable(fgets(this.iHandle, 65000), val(fgets(this.iHandle, 65000)))
  747.         do case
  748.             case inlist(this.cType, PRJTYPE_FORM, PRJTYPE_VCX, PRJTYPE_MENU, ;
  749.                 PRJTYPE_REPORT, PRJTYPE_LABEL)
  750.                 this.WriteTable
  751.             otherwise
  752.                 this.Cancel(ERR_UNSUPPORTEDFILETYPE_LOC + this.cType)
  753.         endcase
  754.         
  755.         =fclose(this.iHandle)
  756.         this.iHandle = -1
  757.         if inlist(this.cType, PRJTYPE_FORM, PRJTYPE_VCX)
  758.             if this.cType = PRJTYPE_VCX
  759.                 * Additional work may need to be performed on a VCX
  760.                 this.FixUpVCX
  761.             endif
  762.             
  763.             use
  764.             compile form (this.cTableName)
  765.         endif
  766.         use
  767.         return 0 && Success
  768.     endproc
  769.     
  770.     procedure FixUpVCX
  771.         private aClassList, i
  772.         select objname, recno() from dbf() where not deleted() and reserved1 == 'Class' ;
  773.             into array aClassList
  774.         if type('aClassList[1]') <> 'U'
  775.             * If objects were added to or removed from a class during merge, 
  776.             * the record count will be out of sync.
  777.             for m.i = 1 to alen(aClassList, 1)
  778.                 go (aClassList[m.i, 2])
  779.                 if m.i = alen(aClassList, 1)
  780.                     replace reserved2 with ;
  781.                         alltrim(str(reccount() - aClassList[m.i, 2]))
  782.                 else
  783.                     replace reserved2 with ;
  784.                         alltrim(str(aClassList[m.i + 1, 2] - aClassList[m.i, 2] - 1))
  785.                 endif
  786.             endfor
  787.         endif
  788.     endproc
  789.     
  790.     procedure CreateTable
  791.         parameters cFieldlist, iCodePage
  792.         private c1, c2, c3, c4, c5, c6, aStruct
  793.  
  794.         do case
  795.             * BugBug: This is a workaround for the problem with CREATE TABLE and a long
  796.             * field list
  797.             case inlist(this.cType, PRJTYPE_REPORT, PRJTYPE_LABEL)
  798.                 dimension aStruct[75, 4]
  799.                 this.GetReportStructure(@aStruct)
  800.                 create table (this.cTableName) free from array aStruct
  801.                 release aStruct
  802.                 if .not. m.cFieldlist == this.Fieldlist()
  803.                     this.Cancel(ERR_FIELDLISTTOOLONG_LOC)
  804.                 endif
  805.             case len(m.cFieldlist) < 251
  806.                 create table (this.cTableName) free (&cFieldList)
  807.             case len(m.cFieldlist) < 501
  808.                 m.c1 = substr(m.cFieldlist, 1, 250)
  809.                 m.c2 = substr(m.cFieldlist, 251)
  810.                 create table (this.cTableName) free (&c1&c2)
  811.             case len(m.cFieldlist) < 751
  812.                 m.c1 = substr(m.cFieldlist, 1, 250)
  813.                 m.c2 = substr(m.cFieldlist, 251, 250)
  814.                 m.c3 = substr(m.cFieldlist, 501)
  815.                 create table (this.cTableName) free (&c1&c2&c3)
  816.             case len(m.cFieldlist) < 1001
  817.                 m.c1 = substr(m.cFieldlist, 1, 250)
  818.                 m.c2 = substr(m.cFieldlist, 251, 250)
  819.                 m.c3 = substr(m.cFieldlist, 501, 250)
  820.                 m.c4 = substr(m.cFieldlist, 751)
  821.                 create table (this.cTableName) free (&c1&c2&c3&c4)
  822.             case .f. .and. len(m.cFieldlist) < 1251
  823.                 m.c1 = substr(m.cFieldlist, 1, 250)
  824.                 m.c2 = substr(m.cFieldlist, 251, 250)
  825.                 m.c3 = substr(m.cFieldlist, 501, 250)
  826.                 m.c4 = substr(m.cFieldlist, 751, 250)
  827.                 m.c5 = substr(m.cFieldlist, 1001)
  828.                 * BugBug: This causes an error
  829.                 create table (this.cTableName) free (&c1&c2&c3&c4&c5)
  830.             case .f. .and. len(m.cFieldlist) < 1501
  831.                 m.c1 = substr(m.cFieldlist, 1, 250)
  832.                 m.c2 = substr(m.cFieldlist, 251, 250)
  833.                 m.c3 = substr(m.cFieldlist, 501, 250)
  834.                 m.c4 = substr(m.cFieldlist, 751, 250)
  835.                 m.c5 = substr(m.cFieldlist, 1001, 250)
  836.                 m.c6 = substr(m.cFieldlist, 1251)
  837.                 * BugBug: This causes an error
  838.                 create table (this.cTableName) free (&c1&c2&c3&c4&c5&c6)
  839.             otherwise
  840.                 * Not supported
  841.                 this.Cancel(ERR_FIELDLISTTOOLONG_LOC)
  842.         endcase
  843.         if cpdbf() <> m.iCodePage
  844.             use
  845.             this.SetCodePage(this.cTableName, m.iCodePage)
  846.         endif
  847.         use (this.cTableName) exclusive
  848.     endproc
  849.     
  850.     procedure ValidVersion
  851.         parameters cVersion
  852.         if .not. m.cVersion == SCCTEXTVER_LOC
  853.             this.Cancel(ERR_BADVERSION_LOC)
  854.         endif
  855.     endproc
  856.     
  857.     procedure FieldList
  858.         * Returns a CREATE TABLE compatible field list for the current workarea.
  859.         local cStruct, i
  860.         local array aStruct[1]
  861.         
  862.         =afields(aStruct)
  863.         m.cStruct = ""
  864.         for m.i = 1 to alen(aStruct, 1)
  865.             if .not. empty(m.cStruct)
  866.                 m.cStruct = m.cStruct + ","
  867.             endif
  868.             m.cStruct = m.cStruct + aStruct[m.i, 1] + " " + aStruct[m.i, 2] + ;
  869.                 "(" + alltrim(str(aStruct[m.i, 3])) + "," + ;
  870.                 alltrim(str(aStruct[m.i, 4])) + ")"
  871.         endfor
  872.         
  873.         return m.cStruct
  874.     endproc
  875.     
  876.     procedure CreateVcxCursor
  877.         private iSelect, aClasslist, i, j, iCount, aRec, aStruct
  878.         
  879.         this.cVCXCursor = "_" + sys(3)
  880.         do while used(this.cVCXCursor)
  881.             this.cVCXCursor = "_" + sys(3)
  882.         enddo
  883.         
  884.         * Get an ordered list of the classes in the vcx
  885.         select padr(uniqueid, fsize('uniqueid')), recno() from dbf() ;
  886.             where .not. deleted() .and. reserved1 == "Class" ;
  887.             into array aClasslist order by 1
  888.  
  889.         m.iSelect = select() && The original .VCX
  890.  
  891.         * Create the temporary cursor
  892.         =afields(aStruct)
  893.         create cursor (this.cVCXCursor) from array aStruct
  894.         
  895.         * Copy the header record
  896.         select (m.iSelect)
  897.         go top
  898.         scatter memo to aRec
  899.         insert into (this.cVCXCursor) from array aRec
  900.         
  901.         * Scan through the class list and copy the classes over
  902.         if type('aClassList[1]') <> 'U'
  903.             for m.i = 1 to alen(aClasslist, 1)
  904.                 go (aClasslist[m.i, 2])
  905.                 m.iCount = 1 + val(reserved2)
  906.                 for m.j = 1 to m.iCount
  907.                     scatter memo to aRec
  908.                     insert into (this.cVCXCursor) from array aRec
  909.                     skip
  910.                 endfor
  911.             endfor
  912.         endif
  913.         
  914.         * Close the original file and use the cursor we've created
  915.         use in (m.iSelect)
  916.         
  917.         select (this.cVCXCursor)
  918.     endproc
  919.     
  920.     procedure WriteTextFile
  921.         private iCodePage, aText
  922.         
  923.         use (this.cTableName) exclusive
  924.         
  925.         this.oThermRef.iBasis = reccount()
  926.  
  927.         m.iCodePage = cpdbf()
  928.         
  929.         if this.cType = PRJTYPE_VCX
  930.             this.CreateVcxCursor
  931.         endif
  932.  
  933.         this.iHandle = fcreate(this.cTextName)
  934.         if this.iHandle = -1
  935.             this.Alert(ERR_FCREATE_LOC + this.cTextName)
  936.             return -1
  937.         endif
  938.         
  939.         * First line contains the SCCTEXT version string
  940.         =fputs(this.iHandle, SCCTEXTVER_LOC)
  941.  
  942.         * Second line contains the CREATE TABLE compatible field list
  943.         =fputs(this.iHandle, this.FieldList())
  944.         * Third line contains the code page
  945.         =fputs(this.iHandle, alltrim(str(m.iCodePage)))
  946.         
  947.         do case
  948.         case inlist(this.cType, PRJTYPE_FORM, PRJTYPE_VCX, PRJTYPE_LABEL, ;
  949.             PRJTYPE_REPORT, PRJTYPE_MENU, PRJTYPE_DBC)
  950.             this.WriteText
  951.         otherwise
  952.             this.Cancel(ERR_UNSUPPORTEDFILETYPE_LOC + m.cType)
  953.         endcase
  954.  
  955.         =fclose(this.iHandle)
  956.         this.iHandle = -1
  957.         use
  958.         return 0 && Success
  959.     endproc
  960.  
  961.     procedure WriteTable
  962.         private cLine, bInMemo, cMemo, cEndMark, bBinary, cFieldname, cValue, iSeconds
  963.         m.cLine = ""
  964.         m.bInMemo = .f.
  965.         m.cMemo = ""
  966.         m.cEndMark = ""
  967.         m.bBinary = .f.
  968.         m.cFieldname = ""
  969.         m.cValue = ""
  970.         
  971.         this.oThermRef.Update(fseek(this.iHandle, 0, 1))
  972.         m.iSeconds = seconds()
  973.         
  974.         do while .not. feof(this.iHandle)
  975.             if (seconds() - m.iSeconds > 1)
  976.                 this.oThermRef.Update(fseek(this.iHandle, 0, 1))
  977.                 m.iSeconds = seconds()
  978.             endif
  979.             
  980.             m.cLine = fgets(this.iHandle, 65000)
  981.             
  982.             if m.bInMemo
  983.                 do case
  984.                 case m.cEndMark == m.cLine
  985.                 case rat(m.cEndMark, m.cLine) <> 0
  986.                     if m.bBinary
  987.                         m.cMemo = m.cMemo + ;
  988.                             this.HexStr2BinStr(left(m.cLine, rat(m.cEndMark, m.cLine) - 1))
  989.                     else
  990.                         m.cMemo = m.cMemo + left(m.cLine, rat(m.cEndMark, m.cLine) - 1)
  991.                     endif
  992.                 otherwise
  993.                     if m.bBinary
  994.                         m.cMemo = m.cMemo + this.HexStr2BinStr(m.cLine)
  995.                     else
  996.                         m.cMemo = m.cMemo + m.cLine + CRLF
  997.                     endif
  998.                     loop                
  999.                 endcase
  1000.                 
  1001.                 * Drop out of if/endif to write the memo field
  1002.             else
  1003.                 do case
  1004.                 case empty(m.cLine)
  1005.                     loop
  1006.                 case m.cLine == MARKEOF
  1007.                     * Don't read anything past the [EOF] mark
  1008.                     return
  1009.                 case m.bInMemo .and. m.cEndMark == m.cLine
  1010.                 case this.IsRecordMark(m.cLine)
  1011.                     append blank
  1012.                     loop
  1013.                 case this.IsMemoStartMark(m.cLine, @cFieldname)
  1014.                     m.bInMemo = .t.
  1015.                     m.bBinary = .f.
  1016.                     m.cEndMark = this.SectionMark(m.cFieldname, .f., .f.)
  1017.                     loop
  1018.                 case this.IsBinStartMark(m.cLine, @cFieldname)
  1019.                     m.bInMemo = .t.
  1020.                     m.bBinary = .t.
  1021.                     m.cEndMark = this.SectionMark(m.cFieldname, .f., .t.)
  1022.                     loop
  1023.                 case this.IsFieldMark(m.cLine, @cFieldname, @cValue)
  1024.                     do case
  1025.                     case inlist(type(m.cFieldname), "C", "M")
  1026.                         replace (m.cFieldname) with m.cValue
  1027.                     case type(m.cFieldname) = "N"
  1028.                         replace (m.cFieldname) with val(m.cValue)
  1029.                     case type(m.cFieldname) = "L"
  1030.                         replace (m.cFieldname) with &cValue
  1031.                     otherwise
  1032.                         this.Cancel(ERR_UNSUPPORTEDFIELDTYPE_LOC + type(m.cFieldname))
  1033.                     endcase
  1034.                     loop
  1035.                 otherwise
  1036.                     if this.Alert(ERR_LINENOACTION_LOC + chr(13) + chr(13) + m.cLine + chr(13) + chr(13) + ;
  1037.                         ERR_ALERTCONTINUE_LOC, MB_YESNO) = IDNO
  1038.                         this.Cancel
  1039.                     endif
  1040.                 endcase
  1041.             endif
  1042.             
  1043.             * Write the memo field
  1044.             replace (m.cFieldname) with m.cMemo
  1045.             m.bInMemo = .f.
  1046.             m.cFieldname = ""
  1047.             m.cMemo = ""
  1048.             m.cEndMark = ""
  1049.         enddo
  1050.     endproc
  1051.     
  1052.     procedure IsMemoStartMark
  1053.         parameters cLine, cFieldname
  1054.         private cStartMark, cStartMark2
  1055.         if at(MARKMEMOSTARTWORD, m.cLine) = 1
  1056.             m.cFieldname = strtran(m.cLine, MARKMEMOSTARTWORD, "", 1, 1)
  1057.             m.cFieldname = left(m.cFieldname, rat(MARKMEMOSTARTWORD2, m.cFieldname) - 1)
  1058.             return .t.
  1059.         endif
  1060.         return .f.
  1061.     endproc
  1062.  
  1063.     procedure IsBinStartMark
  1064.         parameters cLine, cFieldname
  1065.         private cStartMark, cStartMark2
  1066.         if at(MARKBINSTARTWORD, m.cLine) = 1
  1067.             m.cFieldname = strtran(m.cLine, MARKBINSTARTWORD, "", 1, 1)
  1068.             m.cFieldname = left(m.cFieldname, rat(MARKBINSTARTWORD2, m.cFieldname) - 1)
  1069.             return .t.
  1070.         endif
  1071.         return .f.
  1072.     endproc
  1073.     
  1074.     procedure IsFieldMark
  1075.         parameters cLine, cFieldname, cValue
  1076.         if at(MARKFIELDSTART, m.cLine) = 1
  1077.             m.cFieldname = strtran(m.cLine, MARKFIELDSTART, "", 1, 1)
  1078.             m.cFieldname = left(m.cFieldname, at(MARKFIELDEND, m.cFieldname) - 1)
  1079.             m.cValue = substr(m.cLine, at(MARKFIELDEND, m.cLine))
  1080.             m.cValue = strtran(m.cValue, MARKFIELDEND, "", 1, 1)
  1081.             return .t.
  1082.         endif
  1083.         return .f.
  1084.     endproc
  1085.     
  1086.     procedure RecordMark
  1087.         parameters cUniqueId
  1088.         =fputs(this.iHandle, "")
  1089.         =fputs(this.iHandle, MARKRECORDSTART + MARKRECORDEND)
  1090.     endproc
  1091.     
  1092.     procedure IsRecordMark
  1093.         parameters cLine
  1094.         if left(m.cLine, len(MARKRECORDSTART)) == MARKRECORDSTART .and. ;
  1095.             right(m.cLine, len(MARKRECORDEND)) == MARKRECORDEND
  1096.             return .t.
  1097.         else
  1098.             return .f.
  1099.         endif
  1100.     endproc
  1101.     
  1102.     procedure WriteText
  1103.         private cExcludeList, cMemoAsCharList, cMemoAsBinList, cCharAsBinList
  1104.         m.cExcludeList = ""
  1105.         m.cMemoAsCharList = ""
  1106.         m.cMemoAsBinList = ""
  1107.         m.cCharAsBinList = ""
  1108.         m.cMemoVariesList = ""
  1109.  
  1110.         do case
  1111.             case inlist(this.cType, PRJTYPE_FORM, PRJTYPE_VCX)
  1112.                 m.cExcludeFields = VCX_EXCLUDE_LIST
  1113.                 m.cMemoAsCharList = VCX_MEMOASCHAR_LIST
  1114.                 m.cMemoAsBinList = VCX_MEMOASBIN_LIST
  1115.                 m.cCharAsBinList = VCX_CHARASBIN_LIST
  1116.                 m.cMemoVariesList = VCX_MEMOVARIES_LIST
  1117.             case inlist(this.cType, PRJTYPE_REPORT, PRJTYPE_LABEL)
  1118.                 m.cExcludeFields = FRX_EXCLUDE_LIST
  1119.                 m.cMemoAsCharList = FRX_MEMOASCHAR_LIST
  1120.                 m.cMemoAsBinList = FRX_MEMOASBIN_LIST
  1121.                 m.cCharAsBinList = FRX_CHARASBIN_LIST
  1122.                 m.cMemoVariesList = FRX_MEMOVARIES_LIST
  1123.             case this.cType = PRJTYPE_MENU
  1124.                 m.cExcludeFields = MNX_EXCLUDE_LIST
  1125.                 m.cMemoAsCharList = MNX_MEMOASCHAR_LIST
  1126.                 m.cMemoAsBinList = MNX_MEMOASBIN_LIST
  1127.                 m.cCharAsBinList = MNX_CHARASBIN_LIST
  1128.                 m.cMemoVariesList = MNX_MEMOVARIES_LIST
  1129.             case this.cType = PRJTYPE_DBC
  1130.                 m.cExcludeFields = DBC_EXCLUDE_LIST
  1131.                 m.cMemoAsCharList = DBC_MEMOASCHAR_LIST
  1132.                 m.cMemoAsBinList = DBC_MEMOASBIN_LIST
  1133.                 m.cCharAsBinList = DBC_CHARASBIN_LIST
  1134.                 m.cMemoVariesList = DBC_MEMOVARIES_LIST
  1135.             otherwise
  1136.                 this.Cancel(ERR_UNSUPPORTEDFILETYPE_LOC + this.cType)
  1137.         endcase
  1138.  
  1139.         scan
  1140.             this.oThermRef.Update(recno())
  1141.             if type("UNIQUEID") <> 'U'
  1142.                 this.RecordMark(UNIQUEID)
  1143.             endif
  1144.             for i = 1 to fcount()
  1145.                 if SKIPEMPTYFIELD and empty(evaluate(field(i)))
  1146.                     loop
  1147.                 endif
  1148.                 do case
  1149.                     case " " + field(i) + " " $ m.cExcludeFields
  1150.                         && skip this field
  1151.                     case " " + field(i) + " " $ m.cMemoAsCharList
  1152.                         && memo fields treated as CHAR
  1153.                         this.CharWrite(field(i))
  1154.                     case type(field(i)) = "C"
  1155.                         if " " + field(i) + " " $ m.cCharAsBinList
  1156.                             this.MemoWrite(field(i), .t.)
  1157.                         else
  1158.                             this.CharWrite(field(i))
  1159.                         endif
  1160.                     case type(field(i)) = "M"
  1161.                         if " " + field(i) + " " $ m.cMemoVariesList
  1162.                             && treat as text or binary based on contents of the memofield
  1163.                             if this.MemoIsBinary(field(i))
  1164.                                 this.MemoWrite(field(i), .t.)
  1165.                             else
  1166.                                 this.MemoWrite(field(i), .f.)
  1167.                             endif
  1168.                         else
  1169.                             if " " + field(i) + " " $ m.cMemoAsBinList
  1170.                                 && memo fields treated as BINARY
  1171.                                 this.MemoWrite(field(i), .t.)
  1172.                             else
  1173.                                 this.MemoWrite(field(i), .f.)
  1174.                             endif
  1175.                         endif
  1176.                     case type(field(i)) = "N"
  1177.                         this.NumWrite(field(i))
  1178.                     case type(field(i)) = "L"
  1179.                         this.BoolWrite(field(i))
  1180.                     otherwise
  1181.                         this.Alert(ERR_UNSUPPORTEDFIELDTYPE_LOC + type(field(i)))
  1182.                 endcase
  1183.             endfor
  1184.         endscan
  1185.         this.EOFMark
  1186.     endproc
  1187.     
  1188.     procedure MemoIsBinary
  1189.         * Scan the memo field to see if it contains binary characters
  1190.         parameters cFieldname
  1191.         private i, bIsBinary, cMemo
  1192.         m.cMemo = &cFieldname
  1193.         m.bIsBinary = .t.
  1194.         do case
  1195.             case chr(0) $ m.cMemo
  1196.             otherwise
  1197.                 m.bIsBinary = .f.
  1198.                 if len(m.cMemo) < 126
  1199.                     for m.i = 1 to len(m.cMemo)
  1200.                         if asc(substr(m.cMemo, m.i, 1)) > 126
  1201.                             m.bIsBinary = .t.
  1202.                             exit
  1203.                         endif
  1204.                     endfor
  1205.                 else
  1206.                     for m.i = 126 to 255
  1207.                         if chr(m.i) $ m.cMemo
  1208.                             m.bIsBinary = .t.
  1209.                             exit
  1210.                         endif
  1211.                     endfor
  1212.                 endif
  1213.         endcase
  1214.         return m.bIsBinary
  1215.     endproc
  1216.     
  1217.     procedure EOFMark
  1218.         =fputs(this.iHandle, MARKEOF)
  1219.     endproc
  1220.     
  1221.     procedure CharWrite
  1222.         parameters cFieldname
  1223.         private cTempfield
  1224.         m.cTempfield = &cFieldname
  1225.         =fputs(this.iHandle, MARKFIELDSTART + m.cFieldname + MARKFIELDEND + m.cTempfield)
  1226.     endproc
  1227.     
  1228.     procedure MemoWrite
  1229.         parameters cFieldname, bBinary
  1230.         private i, iLen, iStart, cBuf, cBinary, cBinaryProgress, iSeconds
  1231.         =fputs(this.iHandle, this.SectionMark(m.cFieldname, .t., m.bBinary))
  1232.         m.iLen = len(&cFieldname)
  1233.         if m.bBinary
  1234.             * If we don't support merging, simply write the checksum
  1235.             if C_WRITECHECKSUMS .and. TextSupport(this.cType) == 1
  1236.                 =fputs(this.iHandle, MARKCHECKSUM + sys(2007, &cFieldname))
  1237.             else
  1238.                 m.cBuf = repl(chr(0), 17)
  1239.                 
  1240.                 m.cBinaryProgress = "0"
  1241.                 this.oThermRef.UpdateTaskMessage(C_BINARYCONVERSION_LOC)
  1242.                 m.iSeconds = seconds()
  1243.                 
  1244.                 for m.i = 1 to int(m.iLen / MAXBINLEN) + iif(m.iLen % MAXBINLEN = 0, 0, 1)
  1245.                     if seconds() - m.iSeconds > 1
  1246.                         m.cBinaryProgress = alltrim(str(int(((m.i * MAXBINLEN) / m.iLen) * 100)))
  1247.                         this.oThermRef.UpdateTaskMessage(C_BINARYCONVERSION_LOC)
  1248.                         m.iSeconds = seconds()
  1249.                     endif
  1250.                     m.cBinary = substr(&cFieldname, ((m.i - 1) * MAXBINLEN) + 1, MAXBINLEN)
  1251.                     for m.j = 1 to int(len(m.cBinary) / 8)
  1252.                         sprintf(@cBuf, "%02X%02X%02X%02X%02X%02X%02X%02X", ;
  1253.                             asc(substr(m.cBinary, ((m.j - 1) * 8) + 1, 1)), ;
  1254.                             asc(substr(m.cBinary, ((m.j - 1) * 8) + 2, 1)), ;
  1255.                             asc(substr(m.cBinary, ((m.j - 1) * 8) + 3, 1)), ;
  1256.                             asc(substr(m.cBinary, ((m.j - 1) * 8) + 4, 1)), ;
  1257.                             asc(substr(m.cBinary, ((m.j - 1) * 8) + 5, 1)), ;
  1258.                             asc(substr(m.cBinary, ((m.j - 1) * 8) + 6, 1)), ;
  1259.                             asc(substr(m.cBinary, ((m.j - 1) * 8) + 7, 1)), ;
  1260.                             asc(substr(m.cBinary, ((m.j - 1) * 8) + 8, 1)))
  1261.                         fwrite(this.iHandle, m.cBuf, 16)
  1262.                     endfor
  1263.                     if len(m.cBinary) % 8 = 0
  1264.                         fputs(this.iHandle, "")
  1265.                     endif
  1266.                 endfor
  1267.                 
  1268.                 if len(m.cBinary) % 8 <> 0
  1269.                     m.cBinary = right(m.cBinary, len(m.cBinary) % 8)
  1270.                     sprintf(@cBuf, replicate("%02X", len(m.cBinary)), ;
  1271.                         asc(substr(m.cBinary, 1, 1)), ;
  1272.                         asc(substr(m.cBinary, 2, 1)), ;
  1273.                         asc(substr(m.cBinary, 3, 1)), ;
  1274.                         asc(substr(m.cBinary, 4, 1)), ;
  1275.                         asc(substr(m.cBinary, 5, 1)), ;
  1276.                         asc(substr(m.cBinary, 6, 1)), ;
  1277.                         asc(substr(m.cBinary, 7, 1)), ;
  1278.                         asc(substr(m.cBinary, 8, 1)))
  1279.                     fwrite(this.iHandle, m.cBuf, len(m.cBinary) * 2)
  1280.                     fputs(this.iHandle, "")
  1281.                 endif
  1282.                 
  1283.                 this.oThermRef.UpdateTaskMessage("")
  1284.             endif
  1285.         else
  1286.             =fwrite(this.iHandle, &cFieldname)
  1287.         endif
  1288.         =fputs(this.iHandle, this.SectionMark(m.cFieldname, .f., m.bBinary))
  1289.     endproc
  1290.  
  1291.     procedure HexStr2BinStr
  1292.         parameters cHexStr
  1293.         private cBinStr, i
  1294.         m.cBinStr = ""
  1295.  
  1296.         m.cHexStr = strtran(m.cHexStr, 'A', chr(asc('9') + 1))
  1297.         m.cHexStr = strtran(m.cHexStr, 'B', chr(asc('9') + 2))
  1298.         m.cHexStr = strtran(m.cHexStr, 'C', chr(asc('9') + 3))
  1299.         m.cHexStr = strtran(m.cHexStr, 'D', chr(asc('9') + 4))
  1300.         m.cHexStr = strtran(m.cHexStr, 'E', chr(asc('9') + 5))
  1301.         m.cHexStr = strtran(m.cHexStr, 'F', chr(asc('9') + 6))
  1302.         
  1303.         for m.i = 1 to len(m.cHexStr) step 2
  1304.             m.cBinStr = m.cBinStr + ;
  1305.                 chr((asc(substr(m.cHexStr, m.i, 1)) - 48) * 16 + asc(substr(m.cHexStr, m.i + 1, 1)) - 48)
  1306.         endfor
  1307.  
  1308.         return m.cBinStr
  1309.     endproc
  1310.     
  1311.     procedure NumWrite
  1312.         * This procedure supports the numerics found in forms, reports, etc. (basically, integers)
  1313.         parameters cFieldname
  1314.         =fputs(this.iHandle, MARKFIELDSTART + m.cFieldname + ;
  1315.             MARKFIELDEND + alltrim(str(&cFieldname, 20)))
  1316.     endproc
  1317.     
  1318.     procedure BoolWrite
  1319.         parameters cFieldname
  1320.         =fputs(this.iHandle, MARKFIELDSTART + m.cFieldname + ;
  1321.             MARKFIELDEND + iif(&cFieldname, ".T.", ".F."))
  1322.     endproc
  1323.     
  1324.     procedure SectionMark
  1325.         parameters cFieldname, lStart, bBinary
  1326.         if m.lStart
  1327.             if m.bBinary
  1328.                 return MARKBINSTARTWORD + m.cFieldname + MARKBINSTARTWORD2
  1329.             else
  1330.                 return MARKMEMOSTARTWORD + m.cFieldname + MARKMEMOSTARTWORD2
  1331.             endif
  1332.         else
  1333.             if m.bBinary
  1334.                 return MARKBINENDWORD + m.cFieldname + MARKBINENDWORD2
  1335.             else
  1336.                 return MARKMEMOENDWORD + m.cFieldname + MARKMEMOENDWORD2
  1337.             endif
  1338.         endif
  1339.     endproc
  1340.  
  1341.     FUNCTION JustPath
  1342.         * Returns just the pathname.
  1343.         LPARAMETERS m.filname
  1344.         m.filname = ALLTRIM(UPPER(m.filname))
  1345.         IF "\" $ m.filname
  1346.            m.filname = SUBSTR(m.filname,1,RAT("\",m.filname))
  1347.            IF RIGHT(m.filname,1) = "\" AND LEN(m.filname) > 1 ;
  1348.                     AND SUBSTR(m.filname,LEN(m.filname)-1,1) <> ":"
  1349.                  filname = SUBSTR(m.filname,1,LEN(m.filname)-1)
  1350.            ENDIF
  1351.            RETURN m.filname
  1352.         ELSE
  1353.            RETURN ""
  1354.         ENDIF
  1355.     ENDFUNC
  1356.     
  1357.     FUNCTION ForceExt
  1358.         * Force filename to have a particular extension.
  1359.         LPARAMETERS m.filname,m.ext
  1360.         LOCAL m.ext
  1361.         IF SUBSTR(m.ext,1,1) = "."
  1362.            m.ext = SUBSTR(m.ext,2,3)
  1363.         ENDIF
  1364.  
  1365.         m.pname = THIS.justpath(m.filname)
  1366.         m.filname = THIS.justfname(UPPER(ALLTRIM(m.filname)))
  1367.         IF AT(".",m.filname) > 0
  1368.            m.filname = SUBSTR(m.filname,1,AT(".",m.filname)-1) + "." + m.ext
  1369.         ELSE
  1370.            m.filname = m.filname + "." + m.ext
  1371.         ENDIF
  1372.         RETURN THIS.addbs(m.pname) + m.filname
  1373.     ENDFUNC
  1374.     
  1375.     FUNCTION JustFname
  1376.         * Return just the filename (i.e., no path) from "filname"
  1377.         LPARAMETERS m.filname
  1378.         IF RAT("\",m.filname) > 0
  1379.            m.filname = SUBSTR(m.filname,RAT("\",m.filname)+1,255)
  1380.         ENDIF
  1381.         IF AT(":",m.filname) > 0
  1382.            m.filname = SUBSTR(m.filname,AT(":",m.filname)+1,255)
  1383.         ENDIF
  1384.         RETURN ALLTRIM(UPPER(m.filname))
  1385.     ENDFUNC
  1386.  
  1387.     FUNCTION AddBS
  1388.         * Add a backslash unless there is one already there.
  1389.         LPARAMETER m.pathname
  1390.         LOCAL m.separator
  1391.         m.separator = IIF(_MAC,":","\")
  1392.         m.pathname = ALLTRIM(UPPER(m.pathname))
  1393.         IF !(RIGHT(m.pathname,1) $ "\:") AND !EMPTY(m.pathname)
  1394.            m.pathname = m.pathname + m.separator
  1395.         ENDIF
  1396.         RETURN m.pathname
  1397.     ENDFUNC
  1398.  
  1399.     FUNCTION JustStem
  1400.         * Return just the stem name from "filname"
  1401.         LPARAMETERS m.filname
  1402.         IF RAT("\",m.filname) > 0
  1403.            m.filname = SUBSTR(m.filname,RAT("\",m.filname)+1,255)
  1404.         ENDIF
  1405.         IF RAT(":",m.filname) > 0
  1406.            m.filname = SUBSTR(m.filname,RAT(":",m.filname)+1,255)
  1407.         ENDIF
  1408.         IF AT(".",m.filname) > 0
  1409.            m.filname = SUBSTR(m.filname,1,AT(".",m.filname)-1)
  1410.         ENDIF
  1411.         RETURN ALLTRIM(UPPER(m.filname))
  1412.     ENDFUNC
  1413.  
  1414.     FUNCTION justext
  1415.         * Return just the extension from "filname"
  1416.         PARAMETERS m.filname
  1417.         LOCAL m.ext
  1418.         m.filname = this.justfname(m.filname)   && prevents problems with ..\ paths
  1419.         m.ext = ""
  1420.         IF AT(".", m.filname) > 0
  1421.            m.ext = SUBSTR(m.filname, AT(".", m.filname) + 1, 3)
  1422.         ENDIF
  1423.         RETURN UPPER(m.ext)
  1424.     ENDFUNC    
  1425.  
  1426.     procedure SetCodePage
  1427.         parameters m.fname, m.iCodePage
  1428.         private iHandle, cpbyte
  1429.  
  1430.         do case
  1431.             case m.iCodePage = 437
  1432.                 m.cpbyte = 1
  1433.             case m.iCodePage = 850
  1434.                 m.cpbyte = 2
  1435.             case m.iCodePage = 1252
  1436.                 m.cpbyte = 3
  1437.             case m.iCodePage = 10000
  1438.                 m.cpbyte = 4
  1439.             case m.iCodePage = 852
  1440.                 m.cpbyte = 100
  1441.             case m.iCodePage = 866
  1442.                 m.cpbyte = 101
  1443.             case m.iCodePage = 865
  1444.                 m.cpbyte = 102
  1445.             case m.iCodePage = 861
  1446.                 m.cpbyte = 103
  1447.             case m.iCodePage = 895
  1448.                 m.cpbyte = 104
  1449.             case m.iCodePage = 620
  1450.                 m.cpbyte = 105
  1451.             case m.iCodePage = 737
  1452.                 m.cpbyte = 106
  1453.             case m.iCodePage = 857
  1454.                 m.cpbyte = 107
  1455.             case m.iCodePage = 863
  1456.                 m.cpbyte = 108
  1457.             case m.iCodePage = 10007
  1458.                 m.cpbyte = 150
  1459.             case m.iCodePage = 10029
  1460.                 m.cpbyte = 151
  1461.             case m.iCodePage = 10006
  1462.                 m.cpbyte = 152
  1463.             case m.iCodePage = 1250
  1464.                 m.cpbyte = 200
  1465.             case m.iCodePage = 1251
  1466.                 m.cpbyte = 201
  1467.             case m.iCodePage = 1253
  1468.                 m.cpbyte = 203
  1469.             case m.iCodePage = 1254
  1470.                 m.cpbyte = 202
  1471.             case m.iCodePage = 1257
  1472.                 m.cpbyte = 204
  1473.             otherwise
  1474.                 * Handle the error
  1475.                 return .f.
  1476.         endcase
  1477.         
  1478.         m.iHandle = fopen(m.fname, 2)
  1479.         if m.iHandle = -1
  1480.             return .f.
  1481.         else
  1482.             =fseek(m.iHandle, 29)
  1483.             =fwrite(m.iHandle, chr(m.cpbyte))
  1484.             =fclose(m.iHandle)
  1485.         endif
  1486.         return .t.
  1487.     endproc
  1488.     
  1489.     procedure GetReportStructure
  1490.         parameters aStruct
  1491.         aStruct[1, 1] = "PLATFORM"
  1492.         aStruct[1, 2] = "C"
  1493.         aStruct[1, 3] = 8
  1494.         aStruct[1, 4] = 0
  1495.         aStruct[2, 1] = "UNIQUEID"
  1496.         aStruct[2, 2] = "C"
  1497.         aStruct[2, 3] = 10
  1498.         aStruct[2, 4] = 0
  1499.         aStruct[3, 1] = "TIMESTAMP"
  1500.         aStruct[3, 2] = "N"
  1501.         aStruct[3, 3] = 10
  1502.         aStruct[3, 4] = 0
  1503.         aStruct[4, 1] = "OBJTYPE"
  1504.         aStruct[4, 2] = "N"
  1505.         aStruct[4, 3] = 2
  1506.         aStruct[4, 4] = 0
  1507.         aStruct[5, 1] = "OBJCODE"
  1508.         aStruct[5, 2] = "N"
  1509.         aStruct[5, 3] = 3
  1510.         aStruct[5, 4] = 0
  1511.         aStruct[6, 1] = "NAME"
  1512.         aStruct[6, 2] = "M"
  1513.         aStruct[6, 3] = 4
  1514.         aStruct[6, 4] = 0
  1515.         aStruct[7, 1] = "EXPR"
  1516.         aStruct[7, 2] = "M"
  1517.         aStruct[7, 3] = 4
  1518.         aStruct[7, 4] = 0
  1519.         aStruct[8, 1] = "VPOS"
  1520.         aStruct[8, 2] = "N"
  1521.         aStruct[8, 3] = 9
  1522.         aStruct[8, 4] = 3
  1523.         aStruct[9, 1] = "HPOS"
  1524.         aStruct[9, 2] = "N"
  1525.         aStruct[9, 3] = 9
  1526.         aStruct[9, 4] = 3
  1527.         aStruct[10, 1] = "HEIGHT"
  1528.         aStruct[10, 2] = "N"
  1529.         aStruct[10, 3] = 9
  1530.         aStruct[10, 4] = 3
  1531.         aStruct[11, 1] = "WIDTH"
  1532.         aStruct[11, 2] = "N"
  1533.         aStruct[11, 3] = 9
  1534.         aStruct[11, 4] = 3
  1535.         aStruct[12, 1] = "STYLE"
  1536.         aStruct[12, 2] = "M"
  1537.         aStruct[12, 3] = 4
  1538.         aStruct[12, 4] = 0
  1539.         aStruct[13, 1] = "PICTURE"
  1540.         aStruct[13, 2] = "M"
  1541.         aStruct[13, 3] = 4
  1542.         aStruct[13, 4] = 0
  1543.         aStruct[14, 1] = "ORDER"
  1544.         aStruct[14, 2] = "M"
  1545.         aStruct[14, 3] = 4
  1546.         aStruct[14, 4] = 0
  1547.         aStruct[15, 1] = "UNIQUE"
  1548.         aStruct[15, 2] = "L"
  1549.         aStruct[15, 3] = 1
  1550.         aStruct[15, 4] = 0
  1551.         aStruct[16, 1] = "COMMENT"
  1552.         aStruct[16, 2] = "M"
  1553.         aStruct[16, 3] = 4
  1554.         aStruct[16, 4] = 0
  1555.         aStruct[17, 1] = "ENVIRON"
  1556.         aStruct[17, 2] = "L"
  1557.         aStruct[17, 3] = 1
  1558.         aStruct[17, 4] = 0
  1559.         aStruct[18, 1] = "BOXCHAR"
  1560.         aStruct[18, 2] = "C"
  1561.         aStruct[18, 3] = 1
  1562.         aStruct[18, 4] = 0
  1563.         aStruct[19, 1] = "FILLCHAR"
  1564.         aStruct[19, 2] = "C"
  1565.         aStruct[19, 3] = 1
  1566.         aStruct[19, 4] = 0
  1567.         aStruct[20, 1] = "TAG"
  1568.         aStruct[20, 2] = "M"
  1569.         aStruct[20, 3] = 4
  1570.         aStruct[20, 4] = 0
  1571.         aStruct[21, 1] = "TAG2"
  1572.         aStruct[21, 2] = "M"
  1573.         aStruct[21, 3] = 4
  1574.         aStruct[21, 4] = 0
  1575.         aStruct[22, 1] = "PENRED"
  1576.         aStruct[22, 2] = "N"
  1577.         aStruct[22, 3] = 5
  1578.         aStruct[22, 4] = 0
  1579.         aStruct[23, 1] = "PENGREEN"
  1580.         aStruct[23, 2] = "N"
  1581.         aStruct[23, 3] = 5
  1582.         aStruct[23, 4] = 0
  1583.         aStruct[24, 1] = "PENBLUE"
  1584.         aStruct[24, 2] = "N"
  1585.         aStruct[24, 3] = 5
  1586.         aStruct[24, 4] = 0
  1587.         aStruct[25, 1] = "FILLRED"
  1588.         aStruct[25, 2] = "N"
  1589.         aStruct[25, 3] = 5
  1590.         aStruct[25, 4] = 0
  1591.         aStruct[26, 1] = "FILLGREEN"
  1592.         aStruct[26, 2] = "N"
  1593.         aStruct[26, 3] = 5
  1594.         aStruct[26, 4] = 0
  1595.         aStruct[27, 1] = "FILLBLUE"
  1596.         aStruct[27, 2] = "N"
  1597.         aStruct[27, 3] = 5
  1598.         aStruct[27, 4] = 0
  1599.         aStruct[28, 1] = "PENSIZE"
  1600.         aStruct[28, 2] = "N"
  1601.         aStruct[28, 3] = 5
  1602.         aStruct[28, 4] = 0
  1603.         aStruct[29, 1] = "PENPAT"
  1604.         aStruct[29, 2] = "N"
  1605.         aStruct[29, 3] = 5
  1606.         aStruct[29, 4] = 0
  1607.         aStruct[30, 1] = "FILLPAT"
  1608.         aStruct[30, 2] = "N"
  1609.         aStruct[30, 3] = 5
  1610.         aStruct[30, 4] = 0
  1611.         aStruct[31, 1] = "FONTFACE"
  1612.         aStruct[31, 2] = "M"
  1613.         aStruct[31, 3] = 4
  1614.         aStruct[31, 4] = 0
  1615.         aStruct[32, 1] = "FONTSTYLE"
  1616.         aStruct[32, 2] = "N"
  1617.         aStruct[32, 3] = 3
  1618.         aStruct[32, 4] = 0
  1619.         aStruct[33, 1] = "FONTSIZE"
  1620.         aStruct[33, 2] = "N"
  1621.         aStruct[33, 3] = 3
  1622.         aStruct[33, 4] = 0
  1623.         aStruct[34, 1] = "MODE"
  1624.         aStruct[34, 2] = "N"
  1625.         aStruct[34, 3] = 3
  1626.         aStruct[34, 4] = 0
  1627.         aStruct[35, 1] = "RULER"
  1628.         aStruct[35, 2] = "N"
  1629.         aStruct[35, 3] = 1
  1630.         aStruct[35, 4] = 0
  1631.         aStruct[36, 1] = "RULERLINES"
  1632.         aStruct[36, 2] = "N"
  1633.         aStruct[36, 3] = 1
  1634.         aStruct[36, 4] = 0
  1635.         aStruct[37, 1] = "GRID"
  1636.         aStruct[37, 2] = "L"
  1637.         aStruct[37, 3] = 1
  1638.         aStruct[37, 4] = 0
  1639.         aStruct[38, 1] = "GRIDV"
  1640.         aStruct[38, 2] = "N"
  1641.         aStruct[38, 3] = 2
  1642.         aStruct[38, 4] = 0
  1643.         aStruct[39, 1] = "GRIDH"
  1644.         aStruct[39, 2] = "N"
  1645.         aStruct[39, 3] = 2
  1646.         aStruct[39, 4] = 0
  1647.         aStruct[40, 1] = "FLOAT"
  1648.         aStruct[40, 2] = "L"
  1649.         aStruct[40, 3] = 1
  1650.         aStruct[40, 4] = 0
  1651.         aStruct[41, 1] = "STRETCH"
  1652.         aStruct[41, 2] = "L"
  1653.         aStruct[41, 3] = 1
  1654.         aStruct[41, 4] = 0
  1655.         aStruct[42, 1] = "STRETCHTOP"
  1656.         aStruct[42, 2] = "L"
  1657.         aStruct[42, 3] = 1
  1658.         aStruct[42, 4] = 0
  1659.         aStruct[43, 1] = "TOP"
  1660.         aStruct[43, 2] = "L"
  1661.         aStruct[43, 3] = 1
  1662.         aStruct[43, 4] = 0
  1663.         aStruct[44, 1] = "BOTTOM"
  1664.         aStruct[44, 2] = "L"
  1665.         aStruct[44, 3] = 1
  1666.         aStruct[44, 4] = 0
  1667.         aStruct[45, 1] = "SUPTYPE"
  1668.         aStruct[45, 2] = "N"
  1669.         aStruct[45, 3] = 1
  1670.         aStruct[45, 4] = 0
  1671.         aStruct[46, 1] = "SUPREST"
  1672.         aStruct[46, 2] = "N"
  1673.         aStruct[46, 3] = 1
  1674.         aStruct[46, 4] = 0
  1675.         aStruct[47, 1] = "NOREPEAT"
  1676.         aStruct[47, 2] = "L"
  1677.         aStruct[47, 3] = 1
  1678.         aStruct[47, 4] = 0
  1679.         aStruct[48, 1] = "RESETRPT"
  1680.         aStruct[48, 2] = "N"
  1681.         aStruct[48, 3] = 2
  1682.         aStruct[48, 4] = 0
  1683.         aStruct[49, 1] = "PAGEBREAK"
  1684.         aStruct[49, 2] = "L"
  1685.         aStruct[49, 3] = 1
  1686.         aStruct[49, 4] = 0
  1687.         aStruct[50, 1] = "COLBREAK"
  1688.         aStruct[50, 2] = "L"
  1689.         aStruct[50, 3] = 1
  1690.         aStruct[50, 4] = 0
  1691.         aStruct[51, 1] = "RESETPAGE"
  1692.         aStruct[51, 2] = "L"
  1693.         aStruct[51, 3] = 1
  1694.         aStruct[51, 4] = 0
  1695.         aStruct[52, 1] = "GENERAL"
  1696.         aStruct[52, 2] = "N"
  1697.         aStruct[52, 3] = 3
  1698.         aStruct[52, 4] = 0
  1699.         aStruct[53, 1] = "SPACING"
  1700.         aStruct[53, 2] = "N"
  1701.         aStruct[53, 3] = 3
  1702.         aStruct[53, 4] = 0
  1703.         aStruct[54, 1] = "DOUBLE"
  1704.         aStruct[54, 2] = "L"
  1705.         aStruct[54, 3] = 1
  1706.         aStruct[54, 4] = 0
  1707.         aStruct[55, 1] = "SWAPHEADER"
  1708.         aStruct[55, 2] = "L"
  1709.         aStruct[55, 3] = 1
  1710.         aStruct[55, 4] = 0
  1711.         aStruct[56, 1] = "SWAPFOOTER"
  1712.         aStruct[56, 2] = "L"
  1713.         aStruct[56, 3] = 1
  1714.         aStruct[56, 4] = 0
  1715.         aStruct[57, 1] = "EJECTBEFOR"
  1716.         aStruct[57, 2] = "L"
  1717.         aStruct[57, 3] = 1
  1718.         aStruct[57, 4] = 0
  1719.         aStruct[58, 1] = "EJECTAFTER"
  1720.         aStruct[58, 2] = "L"
  1721.         aStruct[58, 3] = 1
  1722.         aStruct[58, 4] = 0
  1723.         aStruct[59, 1] = "PLAIN"
  1724.         aStruct[59, 2] = "L"
  1725.         aStruct[59, 3] = 1
  1726.         aStruct[59, 4] = 0
  1727.         aStruct[60, 1] = "SUMMARY"
  1728.         aStruct[60, 2] = "L"
  1729.         aStruct[60, 3] = 1
  1730.         aStruct[60, 4] = 0
  1731.         aStruct[61, 1] = "ADDALIAS"
  1732.         aStruct[61, 2] = "L"
  1733.         aStruct[61, 3] = 1
  1734.         aStruct[61, 4] = 0
  1735.         aStruct[62, 1] = "OFFSET"
  1736.         aStruct[62, 2] = "N"
  1737.         aStruct[62, 3] = 3
  1738.         aStruct[62, 4] = 0
  1739.         aStruct[63, 1] = "TOPMARGIN"
  1740.         aStruct[63, 2] = "N"
  1741.         aStruct[63, 3] = 3
  1742.         aStruct[63, 4] = 0
  1743.         aStruct[64, 1] = "BOTMARGIN"
  1744.         aStruct[64, 2] = "N"
  1745.         aStruct[64, 3] = 3
  1746.         aStruct[64, 4] = 0
  1747.         aStruct[65, 1] = "TOTALTYPE"
  1748.         aStruct[65, 2] = "N"
  1749.         aStruct[65, 3] = 2
  1750.         aStruct[65, 4] = 0
  1751.         aStruct[66, 1] = "RESETTOTAL"
  1752.         aStruct[66, 2] = "N"
  1753.         aStruct[66, 3] = 2
  1754.         aStruct[66, 4] = 0
  1755.         aStruct[67, 1] = "RESOID"
  1756.         aStruct[67, 2] = "N"
  1757.         aStruct[67, 3] = 3
  1758.         aStruct[67, 4] = 0
  1759.         aStruct[68, 1] = "CURPOS"
  1760.         aStruct[68, 2] = "L"
  1761.         aStruct[68, 3] = 1
  1762.         aStruct[68, 4] = 0
  1763.         aStruct[69, 1] = "SUPALWAYS"
  1764.         aStruct[69, 2] = "L"
  1765.         aStruct[69, 3] = 1
  1766.         aStruct[69, 4] = 0
  1767.         aStruct[70, 1] = "SUPOVFLOW"
  1768.         aStruct[70, 2] = "L"
  1769.         aStruct[70, 3] = 1
  1770.         aStruct[70, 4] = 0
  1771.         aStruct[71, 1] = "SUPRPCOL"
  1772.         aStruct[71, 2] = "N"
  1773.         aStruct[71, 3] = 1
  1774.         aStruct[71, 4] = 0
  1775.         aStruct[72, 1] = "SUPGROUP"
  1776.         aStruct[72, 2] = "N"
  1777.         aStruct[72, 3] = 2
  1778.         aStruct[72, 4] = 0
  1779.         aStruct[73, 1] = "SUPVALCHNG"
  1780.         aStruct[73, 2] = "L"
  1781.         aStruct[73, 3] = 1
  1782.         aStruct[73, 4] = 0
  1783.         aStruct[74, 1] = "SUPEXPR"
  1784.         aStruct[74, 2] = "M"
  1785.         aStruct[74, 3] = 4
  1786.         aStruct[74, 4] = 0
  1787.         aStruct[75, 1] = "USER"
  1788.         aStruct[75, 2] = "M"
  1789.         aStruct[75, 3] = 4
  1790.         aStruct[75, 4] = 0
  1791.     endproc    
  1792. enddefine
  1793.  
  1794. DEFINE CLASS thermometer AS form
  1795.  
  1796.     Top = 196
  1797.     Left = 142
  1798.     Height = 88
  1799.     Width = 356
  1800.     AutoCenter = .T.
  1801.     BackColor = RGB(192,192,192)
  1802.     BorderStyle = 0
  1803.     Caption = ""
  1804.     Closable = .F.
  1805.     ControlBox = .F.
  1806.     MaxButton = .F.
  1807.     MinButton = .F.
  1808.     Movable = .F.
  1809.     AlwaysOnTop = .F.
  1810.     ipercentage = 0
  1811.     iBasis = 0
  1812.     ccurrenttask = ''
  1813.     shpthermbarmaxwidth = 322
  1814.     cthermref = ""
  1815.     Name = "thermometer"
  1816.  
  1817.     ADD OBJECT shape10 AS shape WITH ;
  1818.         BorderColor = RGB(128,128,128), ;
  1819.         Height = 81, ;
  1820.         Left = 3, ;
  1821.         Top = 3, ;
  1822.         Width = 1, ;
  1823.         Name = "Shape10"
  1824.  
  1825.  
  1826.     ADD OBJECT shape9 AS shape WITH ;
  1827.         BorderColor = RGB(128,128,128), ;
  1828.         Height = 1, ;
  1829.         Left = 3, ;
  1830.         Top = 3, ;
  1831.         Width = 349, ;
  1832.         Name = "Shape9"
  1833.  
  1834.  
  1835.     ADD OBJECT shape8 AS shape WITH ;
  1836.         BorderColor = RGB(255,255,255), ;
  1837.         Height = 82, ;
  1838.         Left = 352, ;
  1839.         Top = 3, ;
  1840.         Width = 1, ;
  1841.         Name = "Shape8"
  1842.  
  1843.  
  1844.     ADD OBJECT shape7 AS shape WITH ;
  1845.         BorderColor = RGB(255,255,255), ;
  1846.         Height = 1, ;
  1847.         Left = 3, ;
  1848.         Top = 84, ;
  1849.         Width = 350, ;
  1850.         Name = "Shape7"
  1851.  
  1852.  
  1853.     ADD OBJECT shape6 AS shape WITH ;
  1854.         BorderColor = RGB(128,128,128), ;
  1855.         Height = 86, ;
  1856.         Left = 354, ;
  1857.         Top = 1, ;
  1858.         Width = 1, ;
  1859.         Name = "Shape6"
  1860.  
  1861.  
  1862.     ADD OBJECT shape4 AS shape WITH ;
  1863.         BorderColor = RGB(128,128,128), ;
  1864.         Height = 1, ;
  1865.         Left = 1, ;
  1866.         Top = 86, ;
  1867.         Width = 354, ;
  1868.         Name = "Shape4"
  1869.  
  1870.  
  1871.     ADD OBJECT shape3 AS shape WITH ;
  1872.         BorderColor = RGB(255,255,255), ;
  1873.         Height = 85, ;
  1874.         Left = 1, ;
  1875.         Top = 1, ;
  1876.         Width = 1, ;
  1877.         Name = "Shape3"
  1878.  
  1879.  
  1880.     ADD OBJECT shape2 AS shape WITH ;
  1881.         BorderColor = RGB(255,255,255), ;
  1882.         Height = 1, ;
  1883.         Left = 1, ;
  1884.         Top = 1, ;
  1885.         Width = 353, ;
  1886.         Name = "Shape2"
  1887.  
  1888.  
  1889.     ADD OBJECT shape1 AS shape WITH ;
  1890.         BackStyle = 0, ;
  1891.         Height = 88, ;
  1892.         Left = 0, ;
  1893.         Top = 0, ;
  1894.         Width = 356, ;
  1895.         Name = "Shape1"
  1896.  
  1897.  
  1898.     ADD OBJECT shape5 AS shape WITH ;
  1899.         BorderStyle = 0, ;
  1900.         FillColor = RGB(192,192,192), ;
  1901.         FillStyle = 0, ;
  1902.         Height = 15, ;
  1903.         Left = 17, ;
  1904.         Top = 47, ;
  1905.         Width = 322, ;
  1906.         Name = "Shape5"
  1907.  
  1908.  
  1909.     ADD OBJECT lbltitle AS label WITH ;
  1910.         FontName = WIN32FONT, ;
  1911.         FontSize = 8, ;
  1912.         BackStyle = 0, ;
  1913.         BackColor = RGB(192,192,192), ;
  1914.         Caption = "", ;
  1915.         Height = 16, ;
  1916.         Left = 18, ;
  1917.         Top = 14, ;
  1918.         Width = 319, ;
  1919.         WordWrap = .F., ;
  1920.         Name = "lblTitle"
  1921.  
  1922.  
  1923.     ADD OBJECT lbltask AS label WITH ;
  1924.         FontName = WIN32FONT, ;
  1925.         FontSize = 8, ;
  1926.         BackStyle = 0, ;
  1927.         BackColor = RGB(192,192,192), ;
  1928.         Caption = "", ;
  1929.         Height = 16, ;
  1930.         Left = 18, ;
  1931.         Top = 27, ;
  1932.         Width = 319, ;
  1933.         WordWrap = .F., ;
  1934.         Name = "lblTask"
  1935.  
  1936.  
  1937.     ADD OBJECT shpthermbar AS shape WITH ;
  1938.         BorderStyle = 0, ;
  1939.         FillColor = RGB(128,128,128), ;
  1940.         FillStyle = 0, ;
  1941.         Height = 16, ;
  1942.         Left = 17, ;
  1943.         Top = 46, ;
  1944.         Width = 0, ;
  1945.         Name = "shpThermBar"
  1946.  
  1947.  
  1948.     ADD OBJECT lblpercentage AS label WITH ;
  1949.         FontName = WIN32FONT, ;
  1950.         FontSize = 8, ;
  1951.         BackStyle = 0, ;
  1952.         Caption = "0%", ;
  1953.         Height = 13, ;
  1954.         Left = 170, ;
  1955.         Top = 47, ;
  1956.         Width = 16, ;
  1957.         Name = "lblPercentage"
  1958.  
  1959.  
  1960.     ADD OBJECT lblpercentage2 AS label WITH ;
  1961.         FontName = WIN32FONT, ;
  1962.         FontSize = 8, ;
  1963.         BackColor = RGB(0,0,255), ;
  1964.         BackStyle = 0, ;
  1965.         Caption = "Label1", ;
  1966.         ForeColor = RGB(255,255,255), ;
  1967.         Height = 13, ;
  1968.         Left = 170, ;
  1969.         Top = 47, ;
  1970.         Width = 0, ;
  1971.         Name = "lblPercentage2"
  1972.  
  1973.  
  1974.     ADD OBJECT shape11 AS shape WITH ;
  1975.         BorderColor = RGB(128,128,128), ;
  1976.         Height = 1, ;
  1977.         Left = 16, ;
  1978.         Top = 45, ;
  1979.         Width = 322, ;
  1980.         Name = "Shape11"
  1981.  
  1982.  
  1983.     ADD OBJECT shape12 AS shape WITH ;
  1984.         BorderColor = RGB(255,255,255), ;
  1985.         Height = 1, ;
  1986.         Left = 16, ;
  1987.         Top = 61, ;
  1988.         Width = 323, ;
  1989.         Name = "Shape12"
  1990.  
  1991.  
  1992.     ADD OBJECT shape13 AS shape WITH ;
  1993.         BorderColor = RGB(128,128,128), ;
  1994.         Height = 16, ;
  1995.         Left = 16, ;
  1996.         Top = 45, ;
  1997.         Width = 1, ;
  1998.         Name = "Shape13"
  1999.  
  2000.  
  2001.     ADD OBJECT shape14 AS shape WITH ;
  2002.         BorderColor = RGB(255,255,255), ;
  2003.         Height = 17, ;
  2004.         Left = 338, ;
  2005.         Top = 45, ;
  2006.         Width = 1, ;
  2007.         Name = "Shape14"
  2008.  
  2009.  
  2010.     ADD OBJECT lblescapemessage AS label WITH ;
  2011.         FontBold = .F., ;
  2012.         FontName = WIN32FONT, ;
  2013.         FontSize = 8, ;
  2014.         Alignment = 2, ;
  2015.         BackStyle = 0, ;
  2016.         BackColor = RGB(192,192,192), ;
  2017.         Caption = "", ;
  2018.         Height = 14, ;
  2019.         Left = 17, ;
  2020.         Top = 68, ;
  2021.         Width = 322, ;
  2022.         WordWrap = .F., ;
  2023.         Name = "lblEscapeMessage"
  2024.  
  2025.     PROCEDURE complete
  2026.         * This is the default complete message
  2027.         parameters m.cTask
  2028.         private iSeconds
  2029.         if parameters() = 0
  2030.             m.cTask = THERMCOMPLETE_LOC
  2031.         endif
  2032.         this.Update(100,m.cTask)
  2033.     ENDPROC
  2034.  
  2035.     procedure UpdateTaskMessage
  2036.         * Update the task message only, used when converting binary data
  2037.         parameters cTask
  2038.         this.cCurrentTask = m.cTask
  2039.         this.lblTask.Caption = this.cCurrentTask
  2040.     endproc
  2041.     
  2042.     PROCEDURE update
  2043.         * m.iProgress is the percentage complete
  2044.         * m.cTask is displayed on the second line of the window
  2045.  
  2046.         parameters iProgress, cTask
  2047.  
  2048.         if parameters() >= 2 .and. type('m.cTask') = 'C'
  2049.             * If we're specifically passed a null string, clear the current task,
  2050.             * otherwise leave it alone
  2051.             this.cCurrentTask = m.cTask
  2052.         endif
  2053.         
  2054.         if ! this.lblTask.Caption == this.cCurrentTask
  2055.             this.lblTask.Caption = this.cCurrentTask
  2056.         endif
  2057.  
  2058.         if this.iBasis <> 0
  2059.             * interpret m.iProgress in terms of this.iBasis
  2060.             m.iPercentage = int((m.iProgress / this.iBasis) * 100)
  2061.         else
  2062.             m.iPercentage = m.iProgress
  2063.         endif
  2064.         
  2065.         m.iPercentage = min(100,max(0,m.iPercentage))
  2066.         
  2067.         if m.iPercentage = this.iPercentage
  2068.             RETURN
  2069.         endif
  2070.         
  2071.         if len(alltrim(str(m.iPercentage,3)))<>len(alltrim(str(this.iPercentage,3)))
  2072.             iAvgCharWidth=fontmetric(6,this.lblPercentage.FontName, ;
  2073.                 this.lblPercentage.FontSize, ;
  2074.                 iif(this.lblPercentage.FontBold,'B','')+ ;
  2075.                 iif(this.lblPercentage.FontItalic,'I',''))
  2076.             this.lblPercentage.Width=txtwidth(alltrim(str(m.iPercentage,3)) + '%', ;
  2077.                 this.lblPercentage.FontName,this.lblPercentage.FontSize, ;
  2078.                 iif(this.lblPercentage.FontBold,'B','')+ ;
  2079.                 iif(this.lblPercentage.FontItalic,'I','')) * iAvgCharWidth
  2080.             this.lblPercentage.Left=int((this.shpThermBarMaxWidth- ;
  2081.                 this.lblPercentage.Width) / 2)+this.shpThermBar.Left-1
  2082.             this.lblPercentage2.Left=this.lblPercentage.Left
  2083.         endif
  2084.         this.shpThermBar.Width = int((this.shpThermBarMaxWidth)*m.iPercentage/100)
  2085.         this.lblPercentage.Caption = alltrim(str(m.iPercentage,3)) + '%'
  2086.         this.lblPercentage2.Caption = this.lblPercentage.Caption
  2087.         if this.shpThermBar.Left + this.shpThermBar.Width -1 >= ;
  2088.             this.lblPercentage2.Left
  2089.             if this.shpThermBar.Left + this.shpThermBar.Width - 1 >= ;
  2090.                 this.lblPercentage2.Left + this.lblPercentage.Width - 1
  2091.                 this.lblPercentage2.Width = this.lblPercentage.Width
  2092.             else
  2093.                 this.lblPercentage2.Width = ;
  2094.                     this.shpThermBar.Left + this.shpThermBar.Width - ;
  2095.                     this.lblPercentage2.Left - 1
  2096.             endif
  2097.         else
  2098.             this.lblPercentage2.Width = 0
  2099.         endif
  2100.         this.iPercentage = m.iPercentage
  2101.     ENDPROC
  2102.  
  2103.     PROCEDURE Init
  2104.         * m.cTitle is displayed on the first line of the window
  2105.         * m.iInterval is the frequency used for updating the thermometer
  2106.         parameters cTitle, iInterval
  2107.         this.lblTitle.Caption = iif(empty(m.cTitle),'',m.cTitle)
  2108.         this.shpThermBar.FillColor = rgb(128,128,128)
  2109.         local cColor
  2110.  
  2111.         * Check to see if the fontmetrics for MS Sans Serif matches
  2112.         * those on the system developed. If not, switch to Arial. 
  2113.         * The RETURN value indicates whether the font was changed.
  2114.         if fontmetric(1, WIN32FONT, 8, '') <> 13 .or. ;
  2115.             fontmetric(4, WIN32FONT, 8, '') <> 2 .or. ;
  2116.             fontmetric(6, WIN32FONT, 8, '') <> 5 .or. ;
  2117.             fontmetric(7, WIN32FONT, 8, '') <> 11
  2118.             this.SetAll('FontName', WIN95FONT)
  2119.         endif
  2120.  
  2121.         m.cColor = rgbscheme(1, 2)
  2122.         m.cColor = 'rgb(' + substr(m.cColor, at(',', m.cColor, 3) + 1)
  2123.         this.BackColor = &cColor
  2124.         this.Shape5.FillColor = &cColor
  2125.     ENDPROC
  2126. ENDDEFINE
  2127.